home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp2.arc / XLSETF.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-01-01  |  2.0 KB  |  83 lines
  1. /* xlsetf - set field function */
  2.  
  3. #include "xlisp.h"
  4.  
  5. /* external variables */
  6. extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
  7. extern NODE *xlstack;
  8.  
  9. /* xsetf - built-in function 'setf' */
  10. NODE *xsetf(args)
  11.   NODE *args;
  12. {
  13.     NODE *oldstk,arg,place,value;
  14.  
  15.     /* create a new stack frame */
  16.     oldstk = xlsave(&arg,&place,&value,NULL);
  17.  
  18.     /* initialize */
  19.     arg.n_ptr = args;
  20.  
  21.     /* handle each pair of arguments */
  22.     while (arg.n_ptr) {
  23.  
  24.     /* get place and value */
  25.     place.n_ptr = xlarg(&arg.n_ptr);
  26.     value.n_ptr = xlevarg(&arg.n_ptr);
  27.  
  28.     /* check the place form */
  29.     if (symbolp(place.n_ptr))
  30.         assign(place.n_ptr,value.n_ptr);
  31.     else if (consp(place.n_ptr))
  32.         placeform(place.n_ptr,value.n_ptr);
  33.     else
  34.         xlfail("bad place form");
  35.     }
  36.  
  37.     /* restore the previous stack frame */
  38.     xlstack = oldstk;
  39.  
  40.     /* return the value */
  41.     return (value.n_ptr);
  42. }
  43.  
  44. /* placeform - handle a place form other than a symbol */
  45. LOCAL placeform(place,value)
  46.   NODE *place,*value;
  47. {
  48.     NODE *fun,*oldstk,arg1,arg2;
  49.  
  50.     /* check the function name */
  51.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  52.     oldstk = xlsave(&arg1,&arg2,NULL);
  53.     arg1.n_ptr = xlevmatch(SYM,&place);
  54.     arg2.n_ptr = xlevmatch(SYM,&place);
  55.     xllastarg(place);
  56.     xlputprop(arg1.n_ptr,value,arg2.n_ptr);
  57.     xlstack = oldstk;
  58.     }
  59.     else if (fun == s_svalue || fun == s_splist) {
  60.     oldstk = xlsave(&arg1,NULL);
  61.     arg1.n_ptr = xlevmatch(SYM,&place);
  62.     xllastarg(place);
  63.     if (fun == s_svalue)
  64.         arg1.n_ptr->n_symvalue = value;
  65.     else
  66.         rplacd(arg1.n_ptr->n_symplist,value);
  67.     xlstack = oldstk;
  68.     }
  69.     else if (fun == s_car || fun == s_cdr) {
  70.     oldstk = xlsave(&arg1,NULL);
  71.     arg1.n_ptr = xlevmatch(LIST,&place);
  72.     xllastarg(place);
  73.     if (consp(arg1.n_ptr))
  74.         if (fun == s_car)
  75.         rplaca(arg1.n_ptr,value);
  76.         else
  77.         rplacd(arg1.n_ptr,value);
  78.     xlstack = oldstk;
  79.     }
  80.     else
  81.     xlfail("bad place form");
  82. }
  83.